home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / ehelp.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  12KB  |  339 lines
  1. ;; Copyright (C) 1986 Free Software Foundation, Inc.
  2.  
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is free software; you can redistribute it and/or modify
  6. ;; it under the terms of the GNU General Public License as published by
  7. ;; the Free Software Foundation; either version 1, or (at your option)
  8. ;; any later version.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;; GNU General Public License for more details.
  14.  
  15. ;; You should have received a copy of the GNU General Public License
  16. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  17. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19. (require 'electric)
  20. (provide 'ehelp) 
  21.  
  22. (defvar electric-help-map ()
  23.   "Keymap defining commands available whilst scrolling
  24. through a buffer in electric-help-mode")
  25.  
  26. (put 'electric-help-undefined 'suppress-keymap t)
  27. (if electric-help-map
  28.     ()
  29.   (let ((map (make-keymap)))
  30.     (fillarray map 'electric-help-undefined)
  31.     (define-key map (char-to-string meta-prefix-char) (copy-keymap map))
  32.     (define-key map (char-to-string help-char) 'electric-help-help)
  33.     (define-key map "?" 'electric-help-help)
  34.     (define-key map " " 'scroll-up)
  35.     (define-key map "\^?" 'scroll-down)
  36.     (define-key map "." 'beginning-of-buffer)
  37.     (define-key map "<" 'beginning-of-buffer)
  38.     (define-key map ">" 'end-of-buffer)
  39.     ;(define-key map "\C-g" 'electric-help-exit)
  40.     (define-key map "q" 'electric-help-exit)
  41.     (define-key map "Q" 'electric-help-exit)
  42.     ;;a better key than this?
  43.     (define-key map "r" 'electric-help-retain)
  44.  
  45.     (setq electric-help-map map)))
  46.    
  47. (defun electric-help-mode ()
  48.   "with-electric-help temporarily places its buffer in this mode
  49. \(On exit from with-electric-help, the buffer is put in default-major-mode)"
  50.   (setq buffer-read-only t)
  51.   (setq mode-name "Help")
  52.   (setq major-mode 'help)
  53.   (setq mode-line-buffer-identification '(" Help:  %b"))
  54.   (use-local-map electric-help-map)
  55.   ;; this is done below in with-electric-help
  56.   ;(run-hooks 'electric-help-mode-hook)
  57.   )
  58.  
  59. (defun with-electric-help (thunk &optional buffer noerase)
  60.   "Arguments are THUNK &optional BUFFER NOERASE.
  61. BUFFER defaults to \"*Help*\"
  62. THUNK is a function of no arguments which is called to initialise
  63.  the contents of BUFFER.  BUFFER will be erased before THUNK is called unless
  64.  NOERASE is non-nil.  THUNK will be called with  standard-output  bound to
  65.  the buffer specified by BUFFER
  66.  
  67. After THUNK has been called, this function \"electrically\" pops up a window
  68. in which BUFFER is displayed and allows the user to scroll through that buffer
  69. in electric-help-mode.
  70. When the user exits (with electric-help-exit, or otherwise) the help
  71. buffer's window disappears (ie we use save-window-excursion)
  72. BUFFER is put into default-major-mode (or fundamental-mode) when we exit"
  73.   (setq buffer (get-buffer-create (or buffer "*Help*")))
  74.   (let ((one (one-window-p t))
  75.     (two nil))
  76.     (save-window-excursion
  77.       (save-excursion
  78.     (if one (goto-char (window-start (selected-window))))
  79.     (let ((pop-up-windows t))
  80.       (pop-to-buffer buffer))
  81.     (unwind-protect
  82.         (progn
  83.           (save-excursion
  84.         (set-buffer buffer)
  85.         (electric-help-mode)
  86.         (setq buffer-read-only nil)
  87.         (or noerase (erase-buffer)))
  88.           (let ((standard-output buffer))
  89.         (if (funcall thunk)
  90.             ()
  91.           (set-buffer buffer)
  92.           (set-buffer-modified-p nil)
  93.           (goto-char (point-min))
  94.           (if one (shrink-window-if-larger-than-buffer (selected-window)))))
  95.           (set-buffer buffer)
  96.           (run-hooks 'electric-help-mode-hook)
  97.           (setq two (electric-help-command-loop))
  98.           (cond ((eq (car-safe two) 'retain)
  99.              (setq two (vector (window-height (selected-window))
  100.                        (window-start (selected-window))
  101.                        (window-hscroll (selected-window))
  102.                        (point))))
  103.             (t (setq two nil))))
  104.                   
  105.       (message "")
  106.       (set-buffer buffer)
  107.       (setq buffer-read-only nil)
  108.       (condition-case ()
  109.           (funcall (or default-major-mode 'fundamental-mode))
  110.         (error nil)))))
  111.     (if two
  112.     (let ((pop-up-windows t)
  113.           tem)
  114.       (pop-to-buffer buffer)
  115.       (setq tem (- (window-height (selected-window)) (elt two 0)))
  116.       (if (> tem 0) (shrink-window tem))
  117.       (set-window-start (selected-window) (elt two 1) t)
  118.       (set-window-hscroll (selected-window) (elt two 2))
  119.       (goto-char (elt two 3)))
  120.       ;;>> Perhaps this shouldn't be done.
  121.       ;; so that when we say "Press space to bury" we mean it
  122.       (replace-buffer-in-windows buffer)
  123.       ;; must do this outside of save-window-excursion
  124.       (bury-buffer buffer))))
  125.  
  126. (defun electric-help-command-loop ()
  127.   (catch 'exit
  128.     (if (pos-visible-in-window-p (point-max))
  129.     (progn (message "<<< Press Space to bury the help buffer >>>")
  130.            (if (= (setq unread-command-char (read-char)) ?\  )
  131.            (progn (setq unread-command-char -1)
  132.               (throw 'exit t)))))
  133.     (let (up down both neither
  134.       (standard (and (eq (key-binding " ")
  135.                  'scroll-up)
  136.              (eq (key-binding "\^?")
  137.                  'scroll-down)
  138.              (eq (key-binding "Q")
  139.                  'electric-help-exit)
  140.              (eq (key-binding "q")
  141.                  'electric-help-exit))))
  142.       (Electric-command-loop
  143.         'exit
  144.     (function (lambda ()
  145.       (let ((min (pos-visible-in-window-p (point-min)))
  146.         (max (pos-visible-in-window-p (point-max))))
  147.         (cond ((and min max)
  148.            (cond (standard "Press Q to exit ")
  149.              (neither)
  150.              (t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
  151.           (min
  152.            (cond (standard "Press SPC to scroll, Q to exit ")
  153.              (up)
  154.              (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
  155.           (max
  156.            (cond (standard "Press DEL to scroll back, Q to exit ")
  157.              (down)
  158.              (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
  159.           (t
  160.            (cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
  161.              (both)
  162.              (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
  163.             t))))
  164.  
  165.  
  166.  
  167. ;(defun electric-help-scroll-up (arg)
  168. ;  ">>>Doc"
  169. ;  (interactive "P")
  170. ;  (if (and (null arg) (pos-visible-in-window-p (point-max)))
  171. ;      (electric-help-exit)
  172. ;    (scroll-up arg)))
  173.  
  174. (defun electric-help-exit ()
  175.   ">>>Doc"
  176.   (interactive)
  177.   (throw 'exit t))
  178.  
  179. (defun electric-help-retain ()
  180.   "Exit electric-help, retaining the current window/buffer conifiguration.
  181. \(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
  182. will select it.)"
  183.   (interactive)
  184.   (throw 'exit '(retain)))
  185.  
  186.  
  187. ;(defun electric-help-undefined ()
  188. ;  (interactive)
  189. ;  (let* ((keys (this-command-keys))
  190. ;     (n (length keys)))
  191. ;    (if (or (= n 1)
  192. ;        (and (= n 2)
  193. ;         meta-flag
  194. ;         (eq (aref keys 0) meta-prefix-char)))
  195. ;    (setq unread-command-char last-input-char
  196. ;          current-prefix-arg prefix-arg)
  197. ;      ;;>>> I don't care.
  198. ;      ;;>>> The emacs command-loop is too much pure pain to
  199. ;      ;;>>> duplicate
  200. ;      ))
  201. ;  (throw 'exit t))
  202.  
  203. (defun electric-help-undefined ()
  204.   (interactive)
  205.   (error "%s is undefined -- Press %s to exit"
  206.      (mapconcat 'single-key-description (this-command-keys) " ")
  207.      (if (eq (key-binding "Q") 'electric-help-exit)
  208.          "Q"
  209.        (substitute-command-keys "\\[electric-help-exit]"))))
  210.  
  211.  
  212. ;>>> this needs to be hairified (recursive help, anybody?)
  213. (defun electric-help-help ()
  214.   (interactive)
  215.   (if (and (eq (key-binding "Q") 'electric-help-exit)
  216.        (eq (key-binding " ") 'scroll-up)
  217.        (eq (key-binding "\^?") 'scroll-down))
  218.       (message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
  219.     ;; to give something for user to look at while slow substitute-cmd-keys
  220.     ;;  grinds away
  221.     (message "Help...")
  222.     (message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
  223.   (sit-for 2))
  224.  
  225.  
  226. (defun electric-helpify (fun)
  227.   (let ((name "*Help*"))
  228.     (if (save-window-excursion
  229.       ;; kludge-o-rama
  230.       (let* ((p (symbol-function 'print-help-return-message))
  231.          (b (get-buffer name))
  232.          (m (buffer-modified-p b)))
  233.         (and b (not (get-buffer-window b))
  234.          (setq b nil))
  235.         (unwind-protect
  236.         (progn
  237.           (message "%s..." (capitalize (symbol-name fun)))
  238.           ;; with-output-to-temp-buffer marks the buffer as unmodified.
  239.           ;; kludging excessively and relying on that as some sort
  240.           ;;  of indication leads to the following abomination...
  241.           ;;>> This would be doable without such icky kludges if either
  242.           ;;>> (a) there were a function to read the interactive
  243.           ;;>>     args for a command and return a list of those args.
  244.           ;;>>     (To which one would then just apply the command)
  245.           ;;>>     (The only problem with this is that interactive-p
  246.           ;;>>      would break, but that is such a misfeature in
  247.           ;;>>      any case that I don't care)
  248.           ;;>>     It is easy to do this for emacs-lisp functions;
  249.           ;;>>     the only problem is getting the interactive spec
  250.           ;;>>     for subrs
  251.           ;;>> (b) there were a function which returned a
  252.           ;;>>     modification-tick for a buffer.  One could tell
  253.           ;;>>     whether a buffer had changed by whether the
  254.           ;;>>     modification-tick were different.
  255.           ;;>>     (Presumably there would have to be a way to either
  256.           ;;>>      restore the tick to some previous value, or to
  257.           ;;>>      suspend updating of the tick in order to allow
  258.           ;;>>      things like momentary-string-display)
  259.           (and b
  260.                (save-excursion
  261.              (set-buffer b)
  262.              (set-buffer-modified-p t)))
  263.           (fset 'print-help-return-message 'ignore)
  264.           (call-interactively fun)
  265.           (and (get-buffer name)
  266.                (get-buffer-window (get-buffer name))
  267.                (or (not b)
  268.                (not (eq b (get-buffer name)))
  269.                (not (buffer-modified-p b)))))
  270.           (fset 'print-help-return-message p)
  271.           (and b (buffer-name b)
  272.            (save-excursion
  273.              (set-buffer b)
  274.              (set-buffer-modified-p m))))))
  275.     (with-electric-help 'ignore name t))))
  276.  
  277.  
  278. (defun electric-describe-key ()
  279.   (interactive)
  280.   (electric-helpify 'describe-key))
  281.  
  282. (defun electric-describe-mode ()
  283.   (interactive)
  284.   (electric-helpify 'describe-mode))
  285.  
  286. (defun electric-view-lossage ()
  287.   (interactive)
  288.   (electric-helpify 'view-lossage))
  289.  
  290. ;(defun electric-help-for-help ()
  291. ;  "See help-for-help"
  292. ;  (interactive)
  293. ;  )
  294.  
  295. (defun electric-describe-function ()
  296.   (interactive)
  297.   (electric-helpify 'describe-function))
  298.  
  299. (defun electric-describe-variable ()
  300.   (interactive)
  301.   (electric-helpify 'describe-variable))
  302.  
  303. (defun electric-describe-bindings ()
  304.   (interactive)
  305.   (electric-helpify 'describe-bindings))
  306.  
  307. (defun electric-describe-syntax ()
  308.   (interactive)
  309.   (electric-helpify 'describe-syntax))
  310.  
  311. (defun electric-command-apropos ()
  312.   (interactive)
  313.   (electric-helpify 'command-apropos))
  314.  
  315. ;(define-key help-map "a" 'electric-command-apropos)
  316.  
  317.  
  318.  
  319.  
  320. ;;;; ehelp-map
  321.  
  322. (defvar ehelp-map ())
  323. (if ehelp-map
  324.     nil
  325.   (let ((map (copy-keymap help-map))) 
  326.     (substitute-key-definition 'describe-key 'electric-describe-key map)
  327.     (substitute-key-definition 'describe-mode 'electric-describe-mode map)
  328.     (substitute-key-definition 'view-lossage 'electric-view-lossage map)
  329.     (substitute-key-definition 'describe-function 'electric-describe-function map)
  330.     (substitute-key-definition 'describe-variable 'electric-describe-variable map)
  331.     (substitute-key-definition 'describe-bindings 'electric-describe-bindings map)
  332.     (substitute-key-definition 'describe-syntax 'electric-describe-syntax map)
  333.  
  334.     (setq ehelp-map map)
  335.     (fset 'ehelp-command map)))
  336.  
  337. ;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win
  338.  
  339.